home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / dates.com / DATES.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-07-16  |  3.3 KB  |  114 lines
  1. { The 5 date functions in this unit implement an amazingly efficient algorithm
  2.   used in the Hewlett-Packard 12C calculator. Similar routines in commercial
  3.   libraries are relatively huge and rely on brute force. Dates are stored as
  4.   compact 4 byte LongInts giving the routines an effective range from the 1st
  5.   day A.D. to December 31, 9999. (By then we will use another calander!)
  6.  
  7.   These routines in this unit are donated to the public domain by their author:
  8.   John Roncalio, 34439 Ascott Avenue, Abbotsford, B.C., Canada. V2S 4V6
  9.  
  10.   More date routines are available in the BlueBag unit included with the
  11.   ASG52.ARC file in this section. Also included are lots of routines for the
  12.   CRT, cursors, Printer status testing, strings, windows and data entry. It
  13.   really is worth taking a look at. }
  14.  
  15. {$R-}
  16. UNIT Dates;
  17. INTERFACE
  18. TYPE
  19.  Date = LONGINT;
  20.  DateString = STRING[8]; {'MoDyYear' expected. eg: '07041776' = Independence}
  21.  DofW = 1..7;
  22. CONST
  23.  BadDate = $7FFFFFFF;
  24.  DayName : ARRAY[1..7] OF STRING[9] =
  25.   ('Saturday','Sunday','Monday','Tuesday','Wednesday','Thursday','Friday');
  26.  
  27. FUNCTION DateStringToDate(DS:DateString):Date;
  28. FUNCTION DateToDateString(DT:Date):DateString;
  29. FUNCTION DayOfWeek(DT:Date):DofW;
  30. FUNCTION SysDate:Date;
  31. FUNCTION ValidDate(DS:DateString):BOOLEAN;
  32.  
  33. IMPLEMENTATION
  34. USES Dos;
  35. CONST
  36.  DaysInYr :REAL=365.25;
  37. VAR
  38.  Done,
  39.  LeapYear :BOOLEAN;
  40.  Er       :INTEGER;
  41.  Y,M,D,Z  :LONGINT;
  42.  
  43. FUNCTION DateStringToDate;
  44. BEGIN
  45.  IF NOT ValidDate(DS) THEN DateStringToDate:=BadDate ELSE
  46.  BEGIN
  47.   IF M<=2 THEN Z:=Trunc((Y-1)/4) ELSE Z:=Trunc(Y/4) - Trunc(0.4*M+2.3);
  48.   DateStringToDate:=365*Y+31*(M-1)+D+Z;
  49.  END;
  50. END;
  51.  
  52. FUNCTION DateToDateString;
  53. VAR Ys       : STRING[4];
  54.     Ms,Ds    : STRING[2];
  55.     TempDate : STRING[8];
  56. BEGIN
  57.  Y:=Trunc(DT/DaysInYr); STR(Y:4,Ys); M:=0;
  58.  D:=Trunc((DT/DaysInYr-Y)*DaysInYr+0.00001);
  59.  LeapYear := (Y/4 = Y DIV 4); Done:=False;
  60.  REPEAT
  61.   INC(M);
  62.   CASE M OF
  63.    1,3,5,7,8,10,12 : IF D>31 THEN DEC(D,31) ELSE Done:=True;
  64.    2: IF LeapYear THEN IF D>28 THEN DEC(D,29) ELSE Done:=True
  65.       ELSE IF D>27 THEN DEC(D,28) ELSE Done:=True;
  66.    ELSE IF D>30 THEN DEC(D,30) ELSE Done:=True;
  67.   END; {case}
  68.  UNTIL Done;
  69.  STR(M:2,Ms); STR(D+1:2,Ds); TempDate:=Ms+Ds+Ys;
  70.  FOR D:=1 TO 6 DO IF TempDate[D]=#32 THEN TempDate[D]:='0';
  71.  DateToDateString:=TempDate;
  72. END;
  73.  
  74. FUNCTION DayOfWeek;
  75. VAR Dctr      : BYTE;
  76.     TmpDt     : Date;
  77. BEGIN
  78.  TmpDt:=Dt; Done:=False; Dctr:=0;
  79.  REPEAT
  80.   IF TmpDt/7 = TmpDt DIV 7 THEN Done:=True ELSE
  81.   BEGIN
  82.    INC(Dctr); INC(TmpDt);
  83.   END;
  84.  UNTIL Done;
  85.  DayOfWeek:=7-Dctr;
  86. END;
  87.  
  88. FUNCTION SysDate;
  89. VAR A,B,C,D : WORD;
  90. BEGIN
  91.  GetDate(A,B,C,D); Y:=A; M:=B; D:=C;
  92.  IF M<=2 THEN Z:=Trunc((Y-1)/4) ELSE Z:=Trunc(Y/4) - Trunc(0.4*M+2.3);
  93.  SysDate:=365*Y+31*(M-1)+D+Z;
  94. END;
  95.  
  96. FUNCTION ValidDate;
  97. BEGIN
  98.  ValidDate:=False;
  99.  IF DS[0]<>#8 THEN EXIT;
  100.  VAL(COPY(DS,5,4),Y,Er); IF (Er<>0) OR (Y<0) THEN EXIT;
  101.  VAL(COPY(DS,1,2),M,Er); IF (Er<>0) OR (NOT M IN [1..12]) THEN EXIT;
  102.  VAL(COPY(DS,3,2),D,Er); IF (Er<>0) OR (D<1) THEN EXIT;
  103.  LeapYear := (Y/4 = Y DIV 4);
  104.  CASE M OF
  105.   1,3,5,7,8,10,12:IF D<=31 THEN ValidDate:=True;
  106.   2:IF LeapYear THEN
  107.     BEGIN
  108.      IF D<=29 THEN ValidDate:=True;
  109.     END ELSE IF D<=28 THEN ValidDate:=True;
  110.   ELSE IF D<=30 THEN ValidDate:=True;
  111.  END; {case}
  112. END;
  113.  
  114. END.